home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / MACROEXP.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  15.0 KB  |  451 lines
  1. ; MACROEXP.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*           Macro Expansion and Alpha Conversion            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley          Date: Oct 85            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21. ;*        Alpha conversion technique:                *
  22. ;*                                    *
  23. ;* All lexical identifiers (not global or fluid variables) are changed    *
  24. ;* to "id records" organized as shown:                    *
  25. ;*                                    *
  26. ;*    (#!TOKEN (original-name . unique-number) . <flags>)        *
  27. ;*                                    *
  28. ;* The tag "#!TOKEN" should be considered as a reserved word. What is    *
  29. ;* important is it doesn't conflict with any valid name for primitive     *
  30. ;* operations. The "unique-number" is for human consumption but may    *
  31. ;* also be used to create an assembler label.                *
  32. ;*                                    *
  33. ;* Global and fluid variables are not considered in the "core". The    *
  34. ;* following primitive functions are used to manipulate them:        *
  35. ;*                                    *
  36. ;*        (%%get-global%%   (quote symbol))            *
  37. ;*        (%%set-global%%   (quote symbol) exp)            *
  38. ;*        (%%def-global%%   (quote symbol) exp)            *
  39. ;*                                    *
  40. ;*        (%%get-fluid%%    (quote symbol))            *
  41. ;*        (%%set-fluid%%    (quote symbol) exp)            *
  42. ;*                                    *
  43. ;*        (%%bind-fluid%%   (quote symbol) exp)            *
  44. ;*        (%%unbind-fluid%% (quote (symbol ...)))            *
  45. ;*        (%%fluid-bound?%% (quote symbol))            *
  46. ;*                                    *
  47. ;* Names of official SCHEME 84 primitive functions are not considered    *
  48. ;* to be global variables. When used in the function position of a    *
  49. ;* combination, they are left as atoms. Funarg uses of such primitives    *
  50. ;* are changed to dummy closures:                    *
  51. ;*                                    *
  52. ;*    (foo eq?)    ==>    (foo (lambda (a b) (eq? a b)))        *
  53. ;************************************************************************
  54. ;*            Node annotation:                *
  55. ;*                                    *
  56. ;* Lambda and mulambda nodes are extended with extra "slots" for use    *
  57. ;* during closure analysis as follows. Mulambda's are represented by    *
  58. ;* a negative argument count and a "normalized" argument list.        *
  59. ;*                                    *
  60. ;*    (lambda    bvl    body    nargs    label    debug    closed?)    *
  61. ;*                                    *
  62. ;************************************************************************
  63.  
  64. (define pcs-macro-expand                ; PCS-MACRO-EXPAND
  65.   (lambda (exp)
  66.     (letrec
  67.       ((chk-id        (lambda (e y) (pcs-chk-id e y))); syntax checkers
  68.        (chk-length=    (lambda (e y n) (pcs-chk-length= e y n)))
  69.        (chk-length>=    (lambda (e y n) (pcs-chk-length>= e y n)))
  70.        (chk-bvl        (lambda (a b c) (pcs-chk-bvl a b c)))
  71.        (chk-pairs    (lambda (a b) (pcs-chk-pairs a b)))
  72.        (expand (lambda (x env)
  73.          (cond ((atom? x)
  74.             (exp-atom x env))
  75.                ((macro? (car x))
  76.             (exp-macro x env))
  77.                (else
  78.              (expand2 x env)))))
  79.        (exp-macro (lambda (x env)
  80.             (let ((y (if (pair? macfun)
  81.                  (cons (cdr macfun)(cdr x))    ; alias
  82.                  (macfun x))))            ; macro
  83.               (if (or (atom? y)
  84.                   (equal? x y))
  85.               (expand2 y env)
  86.               (expand y env)))))
  87.        (macfun '())
  88.        (macro? (lambda (id)
  89.          (set! macfun
  90.                (and (symbol? id)
  91.                 (or (getprop id 'PCS*MACRO))))
  92.          macfun))
  93.        (expand2    (lambda (x env)
  94.           (if (atom? x)
  95.               (exp-atom x env)
  96.               (case (car x)
  97.             (quote        (exp-quote x))
  98.             (lambda        (exp-lambda x env))
  99.             (if        (exp-if x env))
  100.             (set!        (exp-set! x env))
  101.             (define        (exp-define x env))
  102.             (begin        (exp-begin x env))
  103.             (letrec        (exp-letrec x env))
  104.             (not        (exp-not x env))
  105.             (else        (exp-application x env))))))
  106.        (exp-quote (lambda (x)
  107.             (chk-length= x x 2)
  108.             x))
  109.        (exp-atom (lambda (x env)
  110.            (cond ((or (null? x)
  111.                   (not (symbol? x))
  112.                   (memq x '(#T #F #!TRUE #!FALSE #!UNASSIGNED)))
  113.               (list 'QUOTE x))
  114.              (else (lookup x env)))))
  115.        (exp-lambda (lambda (x env)
  116.              (chk-length>= x x 3)
  117.              (let ((bvl (lambda-bvl x)))
  118.                (chk-bvl x bvl #T)
  119.                (let ((node (help-lambda bvl
  120.                         (make-contour (lambda-body-list x) env '())
  121.                         '() 0 env)))
  122.              (let ((name (fluid name)))    ; guess at closure name
  123.                (set-lambda-debug
  124.                  node
  125.                  (if pcs-debug-mode
  126.                  (cons (cons 'SOURCE x) name)
  127.                  name)))
  128.              node))))
  129.        (make-contour (lambda (sl env pairs)
  130.                (if (or (null? sl)
  131.                    (atom? (car sl)))
  132.                (make-letrec sl env pairs)
  133.                (let* ((s (car sl))
  134.                   (op (car s)))
  135.                  (if (macro? op)
  136.                  (let* ((y (if (pair? macfun)
  137.                            (cons (cdr macfun)(cdr s))    ; alias
  138.                            (macfun s)))        ; macro
  139.                     (sl (cons y (cdr sl))))
  140.                    (if (equal? s y)
  141.                        (help-contour sl env pairs)    ; exit loop
  142.                        (make-contour sl env pairs)))    ; repeat loop
  143.                  (help-contour sl env pairs))))))
  144.        (help-contour (lambda (sl env pairs)
  145.                (let ((s (car sl)))
  146.              (case (car s)
  147.                (DEFINE
  148.                  (let* ((name (cadr s))
  149.                     (exp  (caddr s))
  150.                     (pair (if (and (symbol? name)
  151.                            (pair? exp)
  152.                            (eq? (car exp) 'NAMED-LAMBDA)
  153.                            (pair? (cdr exp))
  154.                            (pair? (cadr exp))
  155.                            (eq? (car (cadr exp)) name))
  156.                           (let ((bvl (cdr (cadr exp)))
  157.                             (bdy (cddr exp)))
  158.                         `(,name (LAMBDA ,bvl . ,bdy)))
  159.                           (cdr s))))
  160.                    (make-contour (cdr sl) env (cons pair pairs))))
  161.                (BEGIN
  162.                  (make-contour (append (cdr s)(cdr sl)) env pairs))
  163.                (else
  164.                  (make-letrec sl env pairs))))))
  165.        (make-letrec (lambda (sl env pairs)
  166.               (if (null? pairs)
  167.               (make-body sl)
  168.               `(LETREC ,(%reverse! pairs) . ,sl))))
  169.        (help-lambda (lambda (old-bvl body new-bvl nargs env)
  170.               (cond ((null? old-bvl)
  171.                  (let* ((bvl (%reverse! new-bvl))
  172.                     (env (extend env bvl)))
  173.                    (pcs-extend-lambda
  174.                  (list 'LAMBDA
  175.                        (mapcar (lambda (id) (cdr (assq id env)))
  176.                            bvl)
  177.                        (expand body env)
  178.                        nargs))))
  179.                 ((atom? old-bvl)            ; mulambda
  180.                  (help-lambda '()
  181.                       body
  182.                       (cons old-bvl new-bvl)
  183.                       (minus (add1 nargs))
  184.                       env))
  185.                 (else (help-lambda (cdr old-bvl)
  186.                            body
  187.                            (cons (car old-bvl) new-bvl)
  188.                            (add1 nargs)
  189.                            env)))))
  190.  
  191. ;************************************************************************
  192. ;* Below, perform the optimization                    *
  193. ;*                                    *
  194. ;*    (if (or a b) x y)    ===>    (if (and (not a) (not b)) y x)    *
  195. ;*                                    *
  196. ;* which allows the AND macro to generate better code.            *
  197. ;************************************************************************
  198.        (exp-if (lambda (x env)
  199.          (if (or (atom? (cdr x)) (atom? (cddr x)) (atom? (cdddr x)))
  200.              (chk-length= x x 3)
  201.              (chk-length= x x 4))
  202.          (let ((pred (if-pred x))
  203.                (then (if-then x))
  204.                (else (if (null? (cdddr x))
  205.                  ''()
  206.                  (if-else x))))
  207.            (if (and (not (atom? pred))
  208.                 (eq? (car pred) 'OR))
  209.                (list 'IF
  210.                  (expand (cons 'AND
  211.                        (mapcar (lambda (arg) (list 'NOT arg))
  212.                            (cdr pred)))
  213.                      env)
  214.                  (expand else env)
  215.                  (expand then env))
  216.                (list 'IF
  217.                  (expand pred env)
  218.                  (expand then env)
  219.                  (expand else env))))))
  220.  
  221. ;************************************************************************
  222. ;* Below, perform the optimization                    *
  223. ;*                                    *
  224. ;*    (not (or a b))    ===>    (and (not a) (not b))            *
  225. ;*                                    *
  226. ;* which allows the AND macro to generate better code.            *
  227. ;************************************************************************
  228.        (exp-not (lambda (x env)
  229.           (chk-length= x x 2)
  230.           (if (and (primitive? 'NOT env)
  231.                (pair? (cadr x))
  232.                (eq? (car (cadr x)) 'OR))
  233.               (expand
  234.             (cons 'AND (mapcar (lambda (opd) (list 'NOT opd))
  235.                        (cdr (cadr x))))
  236.             env)
  237.               (exp-application x env))))
  238.  
  239.        (exp-set! (lambda (x env)
  240.            (chk-length= x x 3)
  241.            (let* ((id  (set!-id x))
  242.               (var (lookup-LHS id "SET!" env))
  243.               (val (fluid-let ((name id))
  244.                  (expand (set!-exp x) env))))
  245.              (if (atom? var)
  246.              `(%%SET-GLOBAL%% (QUOTE ,var) ,val)
  247.              `(SET! ,var ,val)))))
  248.  
  249.        (exp-define (lambda (x env)
  250.              (chk-length>= x x 3)
  251.              (let* ((id  (set!-id x))
  252.                 (var (lookup-LHS id "DEFINE" env))
  253.                 (val (fluid-let ((name id))
  254.                    (expand (set!-exp x) env))))
  255.                (when (not (null? env))
  256.                  (syntax-error "Incorrectly placed DEFINE" x))
  257.                (if (atom? var)
  258.                `(%%DEF-GLOBAL%% (QUOTE ,id) ,val)    ; global
  259.                `(BEGIN (SET! ,var ,val)        ; lexical
  260.                    (QUOTE ,id))))))
  261.  
  262.        (exp-begin (lambda (x env)
  263.             (chk-length>= x x 1)
  264.             (make-body (mapcar (lambda (s) (expand s env))
  265.                        (help-begin (cdr x) '())))))
  266.  
  267. ;************************************************************************
  268. ;* Below, perform the optimization                    *
  269. ;*                                    *
  270. ;*    (begin ... (or a ...) ...)    ==>                *
  271. ;*                (begin ... (and (not a)...) ...)    *
  272. ;*                                    *
  273. ;* which allows the AND macro to generate better code.            *
  274. ;************************************************************************
  275.        (help-begin (lambda (old new)
  276.              (if (null? old)
  277.              (%reverse! new)
  278.              (help-begin
  279.                (cdr old)
  280.                (cons
  281.                  (let ((s (car old)))
  282.                    (if (and (cdr old)        ; leave last stmt alone
  283.                     (not (atom? s))
  284.                     (eq? (car s) 'OR))
  285.                    (cons 'AND
  286.                      (mapcar (lambda (a) (list 'NOT a))
  287.                          (cdr s)))
  288.                    s))
  289.                  new)))))
  290.  
  291.        (exp-letrec (lambda (x env)
  292.              (chk-length>= x x 3)
  293.              (chk-pairs x (letrec-pairs x))
  294.              (let ((env  (extend env (mapcar car (letrec-pairs x))))
  295.                (body (make-contour (letrec-body-list x) env '())))
  296.                (list 'LETREC
  297.                  (exp-pairs (letrec-pairs x) '() env)
  298.                  (expand body env)))))
  299.  
  300.        (exp-pairs (lambda (old new env)
  301.             (if (null? old)
  302.             (%reverse! new)
  303.             (let ((id  (cdr (assq (caar old) env)))
  304.                   (exp (fluid-let ((name (caar old)))
  305.                      (expand (cadar old) env))))
  306.               (exp-pairs (cdr old)
  307.                      (cons (list id exp) new)
  308.                      env)))))
  309.  
  310.        (exp-application (lambda (form env)
  311.               (chk-length>= form form 1)
  312.               (let ((fn   (car form))
  313.                 (args (cdr form)))
  314.                 (cond ((pair? fn)
  315.                    (let* ((exp (exp-args form '() env))
  316.                       (xfn (car exp)))
  317.                      (cond ((or (atom? xfn)
  318.                         (not (eq? (car xfn) 'LAMBDA)))
  319.                         exp)
  320.                        ((negative? (lambda-nargs xfn))
  321.                         (let ((id (pcs-make-id 'MULAMBDA))) ; must guarantee
  322.                           `(LETREC ((,id ,xfn))            ;  no "mulambda" in
  323.                          (,id . ,(cdr exp)))))      ; "function position"
  324.                        ((= (length args)(lambda-nargs xfn))
  325.                         exp)
  326.                        (else
  327.                          (syntax-error "Wrong number of arguments" form)))))
  328.                   ((symbol? fn)
  329.                    (let ((lex (assq fn env)))
  330.                      (if lex
  331.                      (cons (cdr lex)(exp-args args '() env))
  332.                      (apply-if
  333.                        (lookup-primop fn integrate-global?
  334.                               integrate-primitive?)
  335.                        (lambda (info)
  336.                          (cond ((integer? info)
  337.                             (chk-length= form (cdr form) info)
  338.                             (cons fn (exp-args (cdr form) '() env)))
  339.                            ((pair? info)
  340.                             ;; integrable definition
  341.                             (exp-integrable form (cdr info) (cdr form)
  342.                                     env))
  343.                            (else
  344.                              ;; VM primitive
  345.                              (let ((form2 (info form)))
  346.                                (if (equal? form form2)
  347.                                (cons (car form)
  348.                                  (exp-args
  349.                                    (cdr form) '() env))
  350.                                (expand form2 env))))))
  351.                        (cons (make-global fn)
  352.                          (exp-args args '() env))))))
  353.                   (else
  354.                     (syntax-error "Invalid function name" fn))))))
  355.  
  356.        (exp-args (lambda (old new env)
  357.            (if (null? old)
  358.                (%reverse! new)
  359.                (exp-args (cdr old)
  360.                  (cons (expand (car old) env) new)
  361.                  env))))
  362.  
  363.        (exp-integrable (lambda (form fn args env)
  364.              (letrec ((mismatch
  365.                     (lambda (x y)
  366.                       (cond ((null? x) (not (null? y)))
  367.                         ((atom? x) #F)
  368.                         ((atom? y) #T)
  369.                         (else (mismatch (cdr x)(cdr y)))))))
  370.                (if (and (pair? fn)
  371.                     (eq? (car fn) 'LAMBDA)
  372.                     (pair? (cdr fn))
  373.                     (mismatch (cadr fn) args))
  374.                    (syntax-error "Wrong number of arguments" form)
  375.                    (expand (cons fn args) env)))))
  376.  
  377.        (make-body (lambda (lst)
  378.             (cond ((null? lst)        ''())
  379.               ((null? (cdr lst))    (car lst))
  380.               (else            (cons 'BEGIN lst)))))
  381.  
  382.        (extend (lambda (env bvl)
  383. ; note: error checking done earlier
  384.          (cond (bvl (let* ((var (car bvl))
  385.                    (new (pcs-make-id var))
  386.                    (rib (cons var new)))
  387.                   (extend (cons rib env)
  388.                       (cdr bvl))))
  389.                (env env)
  390.                (else '((()))))))    ; distinguish `empty env' from `no env'
  391.  
  392.        (lookup (lambda (id env)
  393.          (apply-if (getprop id 'PCS*MACRO)
  394.                (lambda (mac)
  395.                  (if (pair? mac)
  396.                  (expand (cdr mac) env)        ; alias
  397.                  (syntax-error            ; macro
  398.                            "Macro name used as variable" id)))
  399.                (apply-if (assq id env)
  400.                  (lambda (lex) (cdr lex))        ; lexical var
  401.                  (let ((info (lookup-primop id integrate-global?
  402.                             integrate-primitive?)))
  403.                    (cond ((or (null? info) (integer? info))
  404.                       (make-global id))
  405.                      ((pair? info)
  406.                       (expand (cdr info) env))
  407.                      (else (expand (info id) env))))))))
  408.  
  409.        (lookup-LHS (lambda (id caller env)
  410.              (if (or (null? id)
  411.                  (not (symbol? id))
  412.                  (getprop id 'PCS*MACRO))    ; macro or alias
  413.              (syntax-error (string-append "Invalid identifier for " caller ": ") id)
  414.              (let ((lex (assq id env)))
  415.                (cond (lex (cdr lex))
  416.                  ((and display-warnings?
  417.                        (lookup-primop id integrate-global?
  418.                               integrate-primitive?))
  419.                   (writeln "[WARNING: modifying an `integrable' variable: " id "]")
  420.                   id)
  421.                  (else id))))))
  422.  
  423.        (lookup-primop (lambda (id integrate-global? integrate-primitive?)
  424.             (and (symbol? id)
  425.                  (let ((info (getprop id 'PCS*PRIMOP-HANDLER)))
  426.                    (and info
  427.                     (if (pair? info) integrate-global? integrate-primitive?)
  428.                     info)))))
  429.  
  430.        (primitive? (lambda (id env)
  431.              (and (not (getprop id 'PCS*MACRO))
  432.               (not (assq id env))
  433.               (let ((info (lookup-primop id #F integrate-primitive?)))
  434.                 (or (integer? info)
  435.                 (closure? info))))))
  436.  
  437.        (make-global (lambda (id)
  438.               `(%%GET-GLOBAL%% (QUOTE ,id))))
  439.  
  440. ;************************************************************************
  441. ;*                data                    *
  442. ;************************************************************************
  443.        (integrate-global?    pcs-integrate-integrables)
  444.        (integrate-primitive?    pcs-integrate-primitives)
  445.        (display-warnings?    pcs-display-warnings)
  446.       )
  447.  
  448.       (fluid-let ((name '()))            ; default lambda "name"
  449.     (expand exp '())))))
  450.  
  451.